BI_retarining_datavis_hw_2

Author

Oksana Plastinina 

library(tidyverse)
── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.2     ✔ tibble    3.3.0
✔ lubridate 1.9.4     ✔ tidyr     1.3.1
✔ purrr     1.1.0     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(treemapify)
library(ggimage)
library(patchwork)
library(ggsignif)

hogwarts <- read_csv("data/hogwarts_2025.csv")
Rows: 560 Columns: 60
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
chr  (4): wandCore, sex, bloodStatus, house
dbl (56): id, course, result, Defence against the dark arts exam, Flying exa...

ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
theme_set(theme_bw())

house_names <- c("Gryffindor" =  "Гриффиндор",
      "Hufflepuff" = "Пуффендуй",
      "Ravenclaw" = "Когтевран",
      "Slytherin" = "Слизерин")
house_colours <- c("Gryffindor" = "#C50000",
                "Hufflepuff" = "#ECB939",
                "Ravenclaw" = "#41A6D9",
                "Slytherin" = "#1F5D25")

wandcore_values <- c('dragon heartstring' = "brown2", 'phoenix feather' = "darkgoldenrod1", 'unicorn hair' = "lightblue4")
wandcore_names <- c('dragon heartstring' = 'сердечная жила дракона', 'phoenix feather' = 'перо феникса', 'unicorn hair' = 'волос единорога')

sex_names = c('female' = 'девочки', 'male' = 'мальчики')
sex_values = c('female' = 'coral2', 'male' = 'deepskyblue2')

bloodStatus_values <- c( 'half-blood' = "lightblue4",
                "muggle-born" = "sienna3",
                "pure-blood" = "mediumpurple4")
bloodStatus_labels <- c(
      'half-blood' = "Полукровка",
      "muggle-born" = "Маглорожденный",
      "pure-blood" = "Чистокровка")

1

При выполнении задания использовался пакет ggsignif. Расширение представляет собой простой способ определения и визуализации статистической значимости различий двух групп. На графике это отображается с помощью скобок, соединяющих интересующие группы с указание значения уровня статистической значимости (в числовой или иной форме).

В домашнем задании №1 мы подробно анализировали распеределения баллов по экзамену по зельеварению у студентов разного происхождения. С помощью данного пакета мы можем статистически уточнить различия между группами и визуализировать это на графике.

В данном случае, на графике ‘Сравнение баллов по зельеварению у студентов разного происхождения’ с помощью теста Вилкоксона сравниваются две группы: маглорожденные - полукровки и маглорожденные - чистокровки. В результате, прямо на графике с помощью автоматического отображения p-value мы показываем значимость различий распределений двух групп (т.к. в обоих случаях p<0.05). Комбинируя значения p и распределение значений, отображаемое боксплотами, мы можем говорить, что маглорожденные студенты получали отметки ниже в сравнении с полукровками и чистокровками.

На графике ‘Сравнение итоговых баллов студентов Хогвартса’ в качестве примера отображены дополнительные возможности пакета. А именно: совместимость пакета с фасетированием, ручное определение формы выводимых результатов теста, ориентацию скобок. Исходя из графика (хотя исходно также очень хорошо было видно) значимые статистические различия между распределениями баллов мальчиков и девочек наблюдаются только у Слизерина, при этом по графику видно, что баллы выше получали девочки.

hogwarts %>% 
  #упорядочиваем переменную происхождения
  mutate(bloodStatus = factor(bloodStatus, level = c ('half-blood', 'muggle-born', 'pure-blood'))) %>% 
  ggplot(aes(x = bloodStatus, y = `Potions exam`))+
  geom_boxplot(aes(fill = bloodStatus),colour = 'grey40', alpha = 0.7)+
  
  #функция пакета ggsignif
  #функция по умолчанию использует wilcox.test
  geom_signif(comparisons = list(
    c('muggle-born', 'half-blood'),
    c('muggle-born', 'pure-blood')), 
    textsize = 5,
    #можем задать расположение скобок по оси у
    y_position = 100.5) +
  
  labs(
    title = 'Сравнение баллов по зельеварению у студентов разного происхождения',
     subtitle = 'Сравнение по происхождению: Тест Манна-Уитни',
    x = NULL,
    y = 'Балл за экзамен'
  )+
  scale_fill_manual(values = bloodStatus_values)+
  scale_x_discrete(labels = bloodStatus_labels)+
  scale_y_continuous(breaks = seq(0,100,10))+
  coord_cartesian(ylim = c(0, 110))+
  theme(
    plot.title = element_text(hjust = 0.5, size = 15 ),
    plot.subtitle = element_text(hjust = 0.5, size = 12, colour = 'grey20'),
    axis.text.x = element_text(color = "black", size = 12),
    axis.text.y = element_text(color = "black", size = 10),
    axis.title = element_text(size = 13),
    legend.position = 'none',
    plot.caption = element_text(size = 8, colour = 'grey25')
  )

hogwarts %>% 
  ggplot(aes(y = sex, x = result))+
  geom_boxplot(aes(fill = house))+
  
  geom_signif(comparisons = list(
    #записываем сравниваемые группы один раз, но после фасетирования в каждой фасете с соотвествующими группами будет проведен свой статистический анализ
    c("female", "male")), 
    textsize = 4,
    #можем задать в каком виде отобразиться значение р, при = TRUE (c("***"=0.001, "**"=0.01, "*"=0.05)). Также можно задать свои градации как в данном случае
    map_signif_level = function(p) {ifelse(p<0.05, 'значимо', 'незначимо')},
    #также можно задать ориентацию расположения скобок
    orientation = 'y'
    )+
  
  facet_grid(house~.,
             labeller = labeller(house = house_names))+
  labs(title = 'Сравнение итоговых баллов студентов Хогвартса',
       subtitle = 'Сравнение по полу: Тест Манна-Уитни',
       x = 'Количество баллов',
       y = NULL)+
  scale_fill_manual(
    values = house_colours,
    labels = house_names)+
  scale_x_continuous(breaks = seq(-250,250,50))+
  scale_y_discrete(labels = sex_names)+
  coord_cartesian(xlim = c(-250, 310))+
  theme(
    plot.title = element_text(hjust = 0.5, size = 15),
    plot.subtitle = element_text(hjust = 0.5, size = 12, colour = 'grey20'),
    legend.position = 'none',
    axis.text.y = element_text(colour = 'black', size = 11),
    axis.text.x = element_text(colour = 'black', size = 10)
  )

2

Treemap позволяет отобразить иерархию категориальной переменной. Здесь площадь каждого прямоугольника пропорцианально соответсвует доли этого варианта признака относительно всей выборки.

Mosaic Plot позволяет визуально сравнить состав нескольких групп. График разделен на столбцы, ширина которых указывает на относительную долю признака от общего количества, высота прямоугольников в группе - доли этого подпризнака внутри группирующего, площадь прямоугольников также как и у Treemap соответствует доли этих пересекающихся признаков от общего числа выборки.

Таким образом, TreeMap подходит для случаев, когда нужно визуализировать иерархию признака и относительные доли групп внутри признака. Mosaic Plot лучше использовать для визуального сравнения подгрупп признака и выявления взаимосвязей.

hogwarts %>% 
  group_by(wandCore, sex) %>% 
  mutate(wandCore = wandcore_names[wandCore]) %>% 
  summarise(n = n(), .groups = "drop") %>% 
  ggplot(aes(area=n, fill = sex, subgroup = wandCore, label =  n))+
  geom_treemap()+
  geom_treemap_subgroup_border(colour = 'grey15')+
  geom_treemap_subgroup_text(
    place = 'bottom',
    size = 20,
    padding.y = grid::unit(3, "mm")
  )+
  geom_treemap_text(place = "centre", size = 15, colour = 'grey20')+
  labs(title = 'Распределение студентов по полу и типам волшебных палочек')+
  scale_fill_manual(
    name = NULL, 
    values = sex_values,
    labels = sex_names
    )+
  theme(
    plot.title = element_text(hjust = 0.5, size =20),
    legend.text = element_text( size = 13))

3

hogwarts %>% 
  mutate(id = as.factor(id)) %>% 
  filter(course == 5) %>% 
  ggplot(aes(x = result, y = fct_reorder(id, result))) +
  geom_segment(aes(xend = -250 , yend = fct_reorder(id, result)), linewidth = 0.8, colour = 'grey40')+
  geom_point(aes(colour = wandCore), shape = 19, size = 2)+
  labs(
    title = 'Распределение годовых баллов студентов 5-ого курса',
    x = 'Количество баллов',
    y = 'ID студента'
  )+
  scale_x_continuous(breaks = seq(-250, 250, 50))+
  scale_colour_manual(
    name = 'Происхождение волшебной палочки',
    labels = wandcore_names,
    values = wandcore_values
  )+
  theme(
    plot.title = element_text(hjust = 0.5, size = 18),
    legend.position = 'bottom',
    legend.justification = 'centre',
    axis.text = element_text(color = "grey25", size = 9),
    axis.title = element_text(size = 13),
    legend.text = element_text(size = 10)
  )

4

Неверные стороны интерпретации данных:

  1. В интерпретации говорится, что график отображает средние, при этом тип графика – столбчатая диаграмма, что не является корректным типом графика для визуализации средних;

  2. Утверждается, что балл «достоверно снижался», но не приводятся критерии достоверности;

  3. График говорит об отрицательной корреляции среднего балла учащегося и количеству прошедших недель учебы, но никак не описывает мотивацию преподавателей и их переход от мотивации учеников к репрессивным действиям, поэтому конечный вывод по данным некорректен.

В качестве вывода против данной теории можно сказать о нелинейности снижения среднего балла. Т.к. столбцы отсортированы не по количеству недель, а по уменьшению среднего балла на неделе, складывается ложный вывод, что увеличение количества недель = уменьшение балла. На деле мы наблюдаем (из неполных данных графика), что средний балл, хоть и действительно во второй половине учебы (неделях 18, 27 и 36) ниже балла на неделях из первой половины учебного года, мы не наблюдаем такой уж прямо пропорциональной зависимости признаков. Так, на 8 неделе средний балл ниже, чем на 11, и оба значения ниже среднего на 14 неделе. Если бы учителя действительно уставали, они бы не завышали баллы на 14 неделе, предварительно занизив их на 8 и 11. Возможно, такие зависимости связаны с изменяемостью сложности домашнего задания и наличию происшествий в школе (нападениями Темного Лорда или матчем по квиддичу);

  1. Интерпретация написана в ненаучном стиле, ближе концу можно судить об агрессивном отношении автора к преподавателям, что ставит под сомнение объективность выводов.

Неверные стороны визуализации данных с помощью графика:

  1. Визуально неприятен. Задний фон отвлекает от данных графика. Много ярких плохо сочетаемых цветов. Нечитаемые надписи. Рассмотреть какие-то данные можно только при большом увеличении картинки;

  2. Некорректные подписей осей, название и описания легенды, а также названия самого графика не дают нам предсталения о данных на соответсвующих частях графика;

  3. В интерпретации и названии говорится, о визуализации среднего балла по каждой неделе обучения, но из 40 недель представлены 5, почему происходит таким образом не поясняется;

  4. Сетка графика избыточно подробная, из-за чего нечитабельна. Поэтому по графику нельзя сказать ни о значении средних, ни о корректности интервалов между ними (т.к. при разнице осечек сетки между средними, высота графиков будет меняться, а с ними и выводы по графику). Также сетка не затрагивает все значения средних, так, даже при читабельности оси у, нельзя сказать, какое среднее на 14 и 36 неделях.

  5. Неясна цель цветовых делений столбцов, интервалов разброса у значений средних и наличие двух легенд;

se <- function(x){
  sd(x, na.rm=TRUE)/sqrt(length(x))
}

min95 <- function(x) {
  mean(x, na.rm=TRUE) - 1.96*sd(x, na.rm=TRUE)/sqrt(length(x))
}

max95 <- function(x) {
  mean(x, na.rm=TRUE) + 1.96*sd(x, na.rm=TRUE)/sqrt(length(x))
}

meanweek_h <- hogwarts %>% 
  select(contains('week_')) %>% 
  pivot_longer(everything(), names_to = 'week_number', values_to = 'score') %>%
  mutate(week_number = factor(str_extract(week_number, "\\d+"), levels = as.character(1:40))) %>% 
  group_by(week_number) %>% 
  summarise(
    'Среднее' = mean(score, na.rm=TRUE),
    'Стандартная ошибка средней' = se(score),
    '2,5%-ый квантиль' = min95(score),
    '97,5%-ый квантиль' = max95(score),
    .groups = 'drop'
  ) 

meanweek_h %>% 
  ggplot(aes (y = week_number, x = Среднее))+
  geom_point(shape = 19, size = 3, colour = 'grey40')+
  geom_errorbar(aes(xmin = `2,5%-ый квантиль`, xmax = `97,5%-ый квантиль` ), width = 0.3, linewidth = 0.5, colour = 'grey40')+
  labs(
    title = 'Средние баллы студентов на каждой неделе обучения',
    caption = 'Примечание: горизонтальные линии показывают 95% доверительный интервал',
    y = 'Номер недели',
    x = 'Значения среднего балла'
  )+
  scale_x_continuous(breaks = seq(-0.5, 2.8, 0.25))+
   theme(
    plot.title = element_text(hjust = 0.5, size = 18),
    plot.caption = element_text( size = 9),
    axis.text = element_text(color = "grey25", size = 10),
    axis.title = element_text(size = 14)
  )

5

podkazka <- read.csv("data/podskazka2.csv")

podkazka %>% 
  ggplot()+
  geom_point(aes(x = X, y = Y))

task2_4 <- meanweek_h %>% 
  rename(ms = `Среднее`) %>% 
  filter(week_number %in% c(8,11,14,18, 27, 36)) %>% 
  ggplot(aes(x = fct_reorder(week_number, ms, .desc = TRUE), y = ms)) +
  geom_col(aes(fill = week_number, colour = week_number), linewidth = 1, alpha = 0.7)+
  geom_errorbar(aes(ymin = ms-0.05, ymax = ms+0.05), width = 0.9, linewidth = 2)+
  geom_line(aes(group = 1), linewidth = 1.8)+
  labs(
    title = 'Эмоциональное выгорание преподавалетей или лень учеников?',
    subtitle = 'Dramatical decreasing of mean score for every subsequent week in Hogwarts'
  )+
  #формируем первую легенду
  scale_colour_manual(
    name = 'colour',
    labels = c('18' = 'blue'),
    values = c('18' = 'pink', '11' = 'pink', '8' ='pink', '14' = 'pink', '27' = 'pink', '36' = 'pink'),
    breaks = '18'
  )+
  
  #формируем вторую легенду
  scale_fill_manual(
    labels = c('18' = '4/6', '11' = '2/6', '8' ='3/6', '14' = '1/6', '27' = '5/6', '36' = '6/6'),
    values = c('18' = 'grey30', '11' = 'olivedrab4', '8' ='tomato', '14' = 'green', '27' = 'darkorange3', '36' = 'black') 
  )+
  
  #задаем порядок легенд
  guides(
    colour = guide_legend(order = 1)
  )+
  
  scale_y_continuous(breaks = seq(0.8,1.9,0.01))+
  coord_cartesian(ylim = c(0.75, 2.2))+
  
  #аннотация у среднего недели 14
  annotate(geom = 'rect', xmin = 1, xmax = 4, ymin = 2.085, ymax = 2.13, fill = 'white', colour = 'green' )+
  annotate(geom = 'text', x = 2.5, y = 2.108, colour = 'green', label = 'В начале учебного года педагоги\n расположены мотивировать учащихся\n и дают им большее количество баллов')+
  
  #аннотация у среднего недели 36
  annotate(geom = 'rect', xmin = 2, xmax = 6, ymin = 0.85, ymax = 0.9, fill = 'white', colour = 'red' )+
  annotate(geom = 'text', x = 4, y = 0.875, colour = 'red', size = 4.5, label = 'К концу года учетеля принимают все\n больше репрессивных мер\n в виде лишения баллов')+
  
  #стрелка к средней 14 недели
  annotate(geom ='curve', x = 3, xend = 1, y = 2.1, yend = 2, arrow=arrow(type = 'closed'), curvature = 0.7, colour = 'green')+
  #стрелка к средней 36 недели
  annotate(geom ='curve', x = 4, xend = 6, y = 0.89, yend = 0.75, arrow=arrow(type = 'closed'), curvature = -0.5, colour = 'red')+
  #стрелка понижения по графику
  annotate(geom ='segment', x = 3, xend = 6, y = 2.08, yend = 0.8, arrow=arrow(type = 'closed'), colour = 'red', linewidth = 2.5)+
  
  theme(
   axis.text = element_text(angle = 90, colour = 'black'),
   plot.title = element_text(size = 10),
   plot.subtitle = element_text(size = 16, colour = 'red3', face = "bold.italic" ),
   #убираем рамку в графике
   panel.border = element_blank(),
   #изменение сетки графика
   panel.grid = element_line(linewidth = 1, colour = 'grey20'),
   legend.text = element_text(size = 13),
   legend.title = element_text(size = 15)
   ) 

ggbackground (task2_4, background = "images/fire_bear_2.png")

6

#генерация вектора с цветами
set.seed(2025)

colours_ <- colours()
res_colours <- colours_[colours_ |> str_detect("grey|gray|black|white", negate = TRUE)]|>  
  sample(size = 36)

#функция для построения гистограммы
histograms_res <- function(n_colour) {
  hogwarts %>% 
  ggplot()+
  geom_histogram(aes(x = result), fill = n_colour, colour = 'black', bins = 20)+
  labs(
    x = 'балл',
    y = 'ученик'
  )+
    scale_x_continuous(breaks = seq(-250,300,100))+
    theme(
      axis.text = element_text(size = 9, colour = 'grey20'),
      axis.title = element_text(colour = 'black', size = 12)
    )
}
  
histograms_res_colour <- map(res_colours,
                             \(n_colour) histograms_res(n_colour) ) 

wrap_plots(histograms_res_colour)+
    plot_annotation(
    title = "Раcпределение итоговых отметок учеников",
    theme = theme(plot.title = element_text(hjust = 0.5, size = 30)))